home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / PASWIZ14.ZIP / SOURCE.ZIP / BCD.PAS next >
Pascal/Delphi Source File  |  1993-02-28  |  14KB  |  586 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. BCD math:
  13.  
  14.    This collection of routines provides powerful support for BCD math.
  15.    Numbers may be up to 255 digits long, with a decimal point anywhere
  16.    you want it.  Trig and other advanced functions are provided as well
  17.    as the more prosaic multiply, divide, subtract, and add.
  18.  
  19. }
  20.  
  21.  
  22.  
  23. UNIT BCD;
  24.  
  25.  
  26.  
  27. INTERFACE
  28.  
  29.  
  30.  
  31. VAR
  32.    LeftD, RightD: Integer;
  33.  
  34.  
  35.  
  36. FUNCTION BCDAbs (Nr: String): String;
  37. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  38. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  39. FUNCTION BCDCos (Nr: String): String;
  40. FUNCTION BCDCot (Nr: String): String;
  41. FUNCTION BCDCsc (Nr: String): String;
  42. FUNCTION BCDDeg2Rad (Nr: String): String;
  43. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  44. FUNCTION BCDe: String;
  45. FUNCTION BCDFact (Num: Integer): String;
  46. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  47. FUNCTION BCDFrac (Nr: String): String;
  48. FUNCTION BCDInt (Nr: String): String;
  49. FUNCTION BCDMul (Nr1, Nr2: String): String;
  50. FUNCTION BCDNeg (Nr: String): String;
  51. FUNCTION BCDpi: String;
  52. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  53. FUNCTION BCDRad2Deg (Nr: String): String;
  54. FUNCTION BCDSec (Nr: String): String;
  55. FUNCTION BCDSet (NumSt: String): String;
  56. FUNCTION BCDSgn (Nr: String): Integer;
  57. FUNCTION BCDSin (Nr: String): String;
  58. FUNCTION BCDSqrt (Nr: String): String;
  59. FUNCTION BCDSub (Nr1, Nr2: String): String;
  60. FUNCTION BCDTan (Nr: String): String;
  61.  
  62.  
  63.  
  64.  
  65. { --------------------------------------------------------------------------- }
  66.  
  67.  
  68.  
  69. IMPLEMENTATION
  70.  
  71.  
  72.  
  73. {$F+}
  74.  
  75. { various helper routines in assembly language }
  76.  
  77. PROCEDURE BCDAdd1 (VAR Nr1: String; Nr2: String); external;
  78. PROCEDURE BCDDiv1L (VAR Nr: String); external;
  79. PROCEDURE BCDDiv1R (VAR Nr: String); external;
  80. PROCEDURE BCDMul1 (VAR Nr: String; Multiplier: Byte); external;
  81. PROCEDURE BCDSub1 (VAR Nr: String); external;
  82.  
  83. FUNCTION BCDAbs; external;
  84. FUNCTION BCDSgn; external;
  85.  
  86. {$L BCDABS}
  87. {$L BCDADD1}
  88. {$L BCDDIV1L}
  89. {$L BCDDIV1R}
  90. {$L BCDMUL1}
  91. {$L BCDSGN}
  92. {$L BCDSUB1}
  93.  
  94.  
  95.  
  96. { local function: complement a number }
  97. FUNCTION Complement (Nr: String): String;
  98. VAR
  99.    St: String;
  100. BEGIN
  101.    St := Nr;
  102.    BCDSub1(St);
  103.    Complement := St;
  104. END;
  105.  
  106.  
  107.  
  108. { local func: create a string of nulls }
  109. FUNCTION NullDupe (DupeCount: Integer): String;
  110. VAR
  111.    tmp: Integer;
  112.    St: String;
  113. BEGIN
  114.    St := '';
  115.    FOR tmp := 1 TO DupeCount DO
  116.       St := St + CHR(0);
  117.    NullDupe := St;
  118. END;
  119.  
  120.  
  121.  
  122. { addition }
  123. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  124. VAR
  125.    Sign1, Sign2, N1, N2: String;
  126. BEGIN
  127.    Sign1 := Copy(Nr1, 1, 1);
  128.    Sign2 := Copy(Nr2, 1, 1);
  129.    N1 := Copy(Nr1, 2, 255);
  130.    N2 := Copy(Nr2, 2, 255);
  131.    IF (Sign1 = Sign2) THEN BEGIN
  132.       BCDAdd1 (N1, N2);
  133.       BCDAdd := Sign1 + N1; END
  134.    ELSE IF (Sign1 = '-') THEN
  135.       BCDAdd := BCDSub(Nr2, ' ' + N1)
  136.    ELSE
  137.       BCDAdd := BCDSub(Nr1, ' ' + N2);
  138. END;
  139.  
  140.  
  141.  
  142. { compare two numbers }
  143. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  144. VAR
  145.    Sign1, Sign2: String;
  146. BEGIN
  147.    Sign1 := Copy(Nr1, 1, 1);
  148.    Sign2 := Copy(Nr2, 1, 1);
  149.    IF Sign1 = Sign2 THEN
  150.       BCDCompare := BCDSgn(BCDSub(' ' + Copy(Nr1, 2, 255), ' ' + Copy(Nr2, 2, 255)))
  151.    ELSE IF (Sign1 = '-') THEN
  152.       BCDCompare := -1
  153.    ELSE
  154.       BCDCompare := 1;
  155. END;
  156.  
  157.  
  158.  
  159. { cosine }
  160. FUNCTION BCDCos (Nr: String): String;
  161. VAR
  162.    One, Two, St, Result, I, X2: String;
  163. BEGIN
  164.    One := BCDSet('1');
  165.    Two := BCDSet('2');
  166.    St := One;
  167.    Result := One;
  168.    I := Two;
  169.    X2 := BCDMul(Nr, Nr);
  170.    WHILE BCDSgn(St) <> 0 DO BEGIN
  171.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  172.       Result := BCDAdd(Result, St);
  173.       I := BCDAdd(I, Two);
  174.    END;
  175.    BCDCos := Result;
  176. END;
  177.  
  178.  
  179.  
  180. { cotangent }
  181. FUNCTION BCDCot (Nr: String): String;
  182. BEGIN
  183.    BCDCot := BCDDiv(BCDCos(Nr), BCDSin(Nr));
  184. END;
  185.  
  186.  
  187.  
  188. { cosecant }
  189. FUNCTION BCDCsc (Nr: String): String;
  190. BEGIN
  191.    BCDCsc := BCDDiv(BCDSet('1'), BCDSin(Nr));
  192. END;
  193.  
  194.  
  195.  
  196. { convert degrees to radians }
  197. FUNCTION BCDDeg2Rad (Nr: String): String;
  198. BEGIN
  199.    BCDDeg2Rad := BCDDiv(BCDMul(Nr, BCDpi), BCDSet('180'));
  200. END;
  201.  
  202.  
  203.  
  204. { division }
  205. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  206. VAR
  207.    Sign1, Sign2, N1, N2, Result, ShiftTrack: String;
  208.    Flip, Ready: Boolean;
  209. BEGIN
  210.    IF BCDSgn(Nr2) = 0 THEN
  211.       BCDDiv := ''
  212.    ELSE IF BCDSgn(Nr1) = 0 THEN
  213.       BCDDiv := Nr1
  214.    ELSE BEGIN
  215.       Sign1 := Copy(Nr1, 1, 1);
  216.       Sign2 := Copy(Nr2, 1, 1);
  217.       N1 := BCDAbs(Nr1);
  218.       N2 := BCDAbs(Nr2);
  219.       Result := BCDSet('0');
  220.       ShiftTrack := BCDSet('1');
  221.       REPEAT
  222.          Flip := FALSE;
  223.          Ready := FALSE;
  224.          REPEAT
  225.             CASE BCDCompare(N2, N1) OF
  226.                -1: BEGIN
  227.                       BCDDiv1L(N2);
  228.                       BCDDiv1L(ShiftTrack);
  229.                       Flip := TRUE;
  230.                    END;
  231.                 0: Ready := TRUE;
  232.                 1: BEGIN
  233.                       BCDDiv1R(N2);
  234.                       BCDDiv1R(ShiftTrack);
  235.                       Ready := Flip;
  236.                    END;
  237.             END;
  238.             IF BCDSgn(ShiftTrack) = 0 THEN Ready := TRUE;
  239.          UNTIL Ready;
  240.          Result := BCDAdd(Result, ShiftTrack);
  241.          N1 := BCDSub(N1, N2);
  242.       UNTIL (BCDSgn(ShiftTrack) = 0) OR (BCDSgn(N1) = 0);
  243.       IF Sign1 = Sign2 THEN
  244.          BCDDiv := Sign1 + Copy(Result, 2, 255)
  245.       ELSE
  246.          BCDDiv := '-' + Copy(Result, 2, 255);
  247.    END;
  248. END;
  249.  
  250.  
  251.  
  252. { the constant "e" }
  253. FUNCTION BCDe: String;
  254. VAR
  255.    St: String;
  256. BEGIN
  257.    St := '2.718281828459045235360287471352662497757247093699959574966';
  258.    St := St + '9676277240766303535475945713821785251664274274663919320031';
  259.    BCDe := BCDSet(St);
  260. END;
  261.  
  262.  
  263.  
  264. { factorial }
  265. FUNCTION BCDFact (Num: Integer): String;
  266. VAR
  267.    One, Result, Mult: String;
  268.    N: Integer;
  269. BEGIN
  270.    One := BCDSet('1');
  271.    Result := One;
  272.    Mult := BCDSet('2');
  273.    FOR N := 2 TO Num DO BEGIN
  274.       Result := BCDMul(Result, Mult);
  275.       Mult := BCDAdd(Mult, One);
  276.    END;
  277.    BCDFact := Result;
  278. END;
  279.  
  280.  
  281.  
  282. { format a number into a text string }
  283. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  284. VAR
  285.   L, R, Sign, T, St: String;
  286.   tmp, ch: Integer;
  287. BEGIN
  288.    Sign := Copy(Nr, 1, 1);
  289.    L := Copy(Nr, 2, LeftD);
  290.    R := Copy(Nr, Length(Nr) - RightD + 1, RightD);
  291.    WHILE Copy(L, 1, 1) = CHR(0) DO
  292.       L := Copy(L, 2, 255);
  293.    IF Length(L) = 0 THEN
  294.       L := CHR(0);
  295.    IF Odd(FormatType) AND (Length(L) > 3) THEN BEGIN
  296.       T := Copy(L, 1, Length(L) - 3);
  297.       L := Copy(L, Length(L) - 2, 3);
  298.       WHILE Length(T) > 3 DO BEGIN
  299.          L := Copy(T, Length(T) - 2, 3) + ',' + L;
  300.          T := Copy(T, 1, Length(T) - 3);
  301.       END;
  302.       L := T + ',' + L;
  303.       IF Copy(L, 1, 1) = ',' THEN L := Copy(L, 2, 255);
  304.    END;
  305.    IF Odd(FormatType SHR 1) THEN
  306.       L := '$' + L;
  307.    IF Odd(FormatType SHR 3) AND (Sign = ' ') THEN
  308.       Sign := '+';
  309.    R := Copy(R, 1, Abs(RightDigits));
  310.    IF RightDigits < 0 THEN
  311.       WHILE Copy(R, Length(R), 1) = CHR(0) DO
  312.          R := Copy(R, 1, Length(R) - 1);
  313.    IF Odd(FormatType SHR 2) THEN
  314.       R := R + Sign
  315.    ELSE
  316.       L := Sign + L;
  317.    St := L + '.' + R;
  318.    IF RightDigits = 0 THEN BEGIN
  319.       tmp := Pos('.', St);
  320.       St := Copy(St, 1, tmp - 1) + Copy(St, tmp + 1, 255);
  321.    END;
  322.    FOR tmp := 1 TO Length(St) DO BEGIN
  323.       ch := ORD(St[tmp]);
  324.       IF ch < 10 THEN
  325.          St[tmp] := CHR(ch + 48);
  326.    END;
  327.    BCDFormat := St;
  328. END;
  329.  
  330.  
  331.  
  332. { keep only the digits to the right of the decimal point }
  333. FUNCTION BCDFrac (Nr: String): String;
  334. VAR
  335.    St: String;
  336.    tmp: Integer;
  337. BEGIN
  338.    St := BCDFormat(Nr, 0, RightD);
  339.    tmp := Pos('.', St);
  340.    IF tmp > 0 THEN
  341.       St := '0' + Copy(St, tmp, 255)
  342.    ELSE
  343.       St := '0';
  344.    BCDFrac := BCDSet(St);
  345. END;
  346.  
  347.  
  348.  
  349. { keep only the digits to the left of the decimal point }
  350. FUNCTION BCDInt (Nr: String): String;
  351. BEGIN
  352.    BCDInt := BCDSet(BCDFormat(Nr, 0, 0));
  353. END;
  354.  
  355.  
  356.  
  357. { multiply }
  358. FUNCTION BCDMul (Nr1, Nr2: String): String;
  359. VAR
  360.    ch: Byte;
  361.    TotalD, tmp2, ShiftVal: Integer;
  362.    Sign, N1, N2, Total, St: String;
  363. BEGIN
  364.    TotalD := LeftD + RightD;
  365.    IF Copy(Nr1, 1, 1) = Copy(Nr2, 1, 1) THEN
  366.       Sign := ' '
  367.    ELSE
  368.       Sign := '-';
  369.    N1 := Copy(Nr1, 2, 255);
  370.    N2 := Copy(Nr2, 2, 255);
  371.    Total := BCDSet('0');
  372.    FOR tmp2 := Length(N2) DOWNTO 1 DO BEGIN
  373.       ch := ORD(N2[tmp2]);
  374.       IF ch <> 0 THEN BEGIN
  375.          St := N1;
  376.          BCDMul1(St, ch);
  377.          IF tmp2 > TotalD - RightD THEN BEGIN
  378.             ShiftVal := RightD - (TotalD - tmp2);
  379.             St := ' ' + NullDupe(ShiftVal) + Copy(St, 1, Length(St) - ShiftVal);
  380.          END
  381.          ELSE BEGIN
  382.             ShiftVal := LeftD - tmp2;
  383.             St := ' ' + Copy(St, ShiftVal + 1, 255) + NullDupe(ShiftVal);
  384.          END;
  385.          Total := BCDAdd(Total, St);
  386.       END;
  387.    END;
  388.    BCDMul := Sign + Copy(Total, 2, 255);
  389. END;
  390.  
  391.  
  392.  
  393. { negate }
  394. FUNCTION BCDNeg (Nr: String): String;
  395. BEGIN
  396.    CASE BCDSgn(Nr) OF
  397.       -1: BCDNeg := ' ' + Copy(Nr, 2, 255);
  398.        0: BCDNeg := Nr;
  399.        1: BCDNeg := '-' + Copy(Nr, 2, 255);
  400.    END;
  401. END;
  402.  
  403.  
  404.  
  405. { the constant "pi" }
  406. FUNCTION BCDpi: String;
  407. VAR
  408.    St: String;
  409. BEGIN
  410.    St := '3.1415926535897932384626433832795028841971';
  411.    St := St + '6939937510582097494459230781640628620899';
  412.    St := St + '8628034825342117067982148086513282306647';
  413.    St := St + '0938446095505822317253594081284811174502';
  414.    St := St + '8410270193852110555964462294895493038196';
  415.    St := St + '4428810975665933446128475648233786783165';
  416.    St := St + '2712019091456';
  417.    BCDpi := BCDSet(St);
  418. END;
  419.  
  420.  
  421.  
  422. { raise a number to a power }
  423. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  424. VAR
  425.    P: Integer;
  426.    Sign, PSeq, Result: String;
  427. BEGIN
  428.    IF Power <= 0 THEN
  429.       BCDPower := BCDSet('1')
  430.    ELSE BEGIN
  431.       Sign := Copy(Nr, 1, 1);
  432.       P := Power;
  433.       Result := BCDSet('1');
  434.       PSeq := BCDAbs(Nr);
  435.       WHILE P > 0 DO BEGIN
  436.          IF Odd(P) THEN Result := BCDMul(Result, PSeq);
  437.          P := P DIV 2;
  438.          PSeq := BCDMul(PSeq, PSeq);
  439.       END;
  440.       IF Odd(Power) THEN
  441.          BCDPower := Sign + Copy(Result, 2, 255)
  442.       ELSE
  443.          BCDPower := Result;
  444.    END;
  445. END;
  446.  
  447.  
  448.  
  449. { convert radians to degrees}
  450. FUNCTION BCDRad2Deg (Nr: String): String;
  451. BEGIN
  452.    BCDRad2Deg := BCDDiv(BCDMul(Nr, BCDSet('180')), BCDpi);
  453. END;
  454.  
  455.  
  456.  
  457. { secant }
  458. FUNCTION BCDSec (Nr: String): String;
  459. BEGIN
  460.    BCDSec := BCDDiv(BCDSet('1'), BCDCos(Nr));
  461. END;
  462.  
  463.  
  464.  
  465. { convert a text string to a BCD number }
  466. FUNCTION BCDSet (NumSt: String): String;
  467. VAR
  468.    tmp, ch: Integer;
  469.    St, Sign, L, R: String;
  470. BEGIN
  471.    St := NumSt;
  472.    WHILE Copy(St, 1, 1) = ' ' DO
  473.       St := Copy(St, 2, 255);
  474.    WHILE Copy(St, Length(St), 1) = ' ' DO
  475.       St := Copy(St, 1, Length(St) - 1);
  476.    FOR tmp := 1 TO Length(St) DO BEGIN
  477.       ch := ORD(St[tmp]);
  478.       IF (ch >= 48) AND (ch <= 57) THEN
  479.          St[tmp] := CHR(ch - 48);
  480.    END;
  481.    IF Copy(St, 1, 1) = '-' THEN BEGIN
  482.       Sign := '-';
  483.       St := Copy(St, 2, 255);
  484.    END
  485.    ELSE
  486.       Sign := ' ';
  487.    tmp := Pos('.', St);
  488.    IF tmp > 0 THEN BEGIN
  489.       L := Copy(St, 1, tmp - 1);
  490.       R := Copy(St, tmp + 1, 255);
  491.    END
  492.    ELSE BEGIN
  493.       L := St;
  494.       R := '';
  495.    END;
  496.    L := NullDupe(LeftD) + L;
  497.    L := Copy(L, Length(L) - LeftD + 1, LeftD);
  498.    R := Copy(R + NullDupe(RightD), 1, RightD);
  499.    BCDSet := Sign + L + R;
  500. END;
  501.  
  502.  
  503.  
  504. { sine }
  505. FUNCTION BCDSin (Nr: String): String;
  506. VAR
  507.    St, Result, One, Two, I, X2: String;
  508. BEGIN
  509.    St := Nr;
  510.    Result := Nr;
  511.    One := BCDSet('1');
  512.    Two := BCDSet('2');
  513.    I := BCDSet('3');
  514.    X2 := BCDMul(Nr, Nr);
  515.    WHILE BCDSgn(St) <> 0 DO BEGIN
  516.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  517.       Result := BCDAdd(Result, St);
  518.       I := BCDAdd(I, Two);
  519.    END;
  520.    BCDSin := Result;
  521. END;
  522.  
  523.  
  524.  
  525. { square root }
  526. FUNCTION BCDSqrt (Nr: String): String;
  527. VAR
  528.    Two, Est1, Est2: String;
  529. BEGIN
  530.    IF Copy(Nr, 1, 1) = '-' THEN
  531.       BCDSqrt := ''
  532.    ELSE BEGIN
  533.       Two := BCDSet('2');
  534.       Est2 := BCDDiv(Nr, Two);
  535.       REPEAT
  536.          Est1 := Est2;
  537.          Est2 := BCDDiv(BCDAdd(Est1, BCDDiv(Nr, Est1)), Two);
  538.       UNTIL BCDCompare(Est1, Est2) = 0;
  539.       BCDSqrt := Est2;
  540.    END;
  541. END;
  542.  
  543.  
  544.  
  545. { subtraction }
  546. FUNCTION BCDSub (Nr1, Nr2: String): String;
  547. VAR
  548.    Sign1, Sign2, N1, N2: String;
  549. BEGIN
  550.    Sign1 := Copy(Nr1, 1, 1);
  551.    Sign2 := Copy(Nr2, 1, 1);
  552.    N1 := Copy(Nr1, 2, 255);
  553.    N2 := Copy(Nr2, 2, 255);
  554.    IF Sign1 = Sign2 THEN BEGIN
  555.       BCDAdd1(N1, Complement(N2));
  556.       IF ORD(N1[1]) = 9 THEN
  557.          IF Sign1 = '-' THEN
  558.             N1 := ' ' + Complement(N1)
  559.          ELSE
  560.             N1 := '-' + Complement(N1)
  561.       ELSE
  562.          N1 := Sign1 + N1;
  563.       BCDSub := N1;
  564.    END
  565.    ELSE BEGIN
  566.       BCDAdd1(N1, N2);
  567.       BCDSub := Sign1 + N1;
  568.    END;
  569. END;
  570.  
  571.  
  572.  
  573. { tangent }
  574. FUNCTION BCDTan (Nr: String): String;
  575. BEGIN
  576.    BCDTan := BCDDiv(BCDSin(Nr), BCDCos(Nr));
  577. END;
  578.  
  579.  
  580.  
  581. { ----------------------- initialization code --------------------------- }
  582. BEGIN
  583.    LeftD := 20;          { digits to the left of the decimal }
  584.    RightD := 11;         { digits to the right of the decimal }
  585. END.
  586.